home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 003 / cforth / forth.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  14KB  |  565 lines
  1. /*
  2.  * forth.c
  3.  * 
  4.  * Portable FORTH interpreter in C
  5.  *
  6.  * Author: Allan Pratt, Indiana University (iuvax!apratt)
  7.  *         Spring, 1984
  8.  * References: 8080 and 6502 fig-FORTH source listings (not the greatest refs
  9.  *         in the world...)
  10.  *
  11.  * This program is intended to be compact, portable, and pretty complete.
  12.  * It is also intended to be in the public domain, and distribution should
  13.  * include this notice to that effect.
  14.  *
  15.  * This file contains the support code for all interpreter functions.
  16.  * the file prims.c contains code for the C-coded primitives, and the
  17.  * file forth.h connects the two with definitions.
  18.  *
  19.  * The program nf.c generates a new forth.core file from the dictionary
  20.  * forth.dict, using common.h to tie it together with this program.
  21.  */
  22.  
  23.  
  24. #include <stdio.h>
  25. #ifndef AMIGA
  26. #include <signal.h>
  27. #endif
  28.  
  29. #include <ctype.h>    /* only for isxdigit */
  30.  
  31. #include "common.h"
  32.  
  33. #include "forth.h"
  34.  
  35. #include "prims.h"    /* macro-defined primitives */
  36.  
  37. /* declare globals which are defined in forth.h */
  38.  
  39. unsigned short csp, rsp, ip, w;
  40. short *mem;
  41. int trace, tracedepth, debug, breakenable, breakpoint, qtermflag, forceip;
  42. int nobuf;
  43. FILE *blockfile;
  44. long bfilesize;
  45. char *bfilename;    /* block file name (change with -f ) */
  46. char *cfilename;    /* core file name  (change with -l ) */
  47. char *sfilename;    /* save file name  (change with -s ) */
  48.  
  49. /*
  50.              ----------------------------------------------------
  51.                                SYSTEM FUNCTIONS
  52.              ----------------------------------------------------
  53. */
  54.  
  55. errexit(s,p1,p2)        /* An error occurred -- clean up (?) and
  56.                    exit. */
  57. {
  58.     printf(s,p1,p2);
  59.     printf("ABORT FORTH!\nDumping to %s... ",DUMPFILE);
  60.     fflush(stdout);
  61.     memdump();
  62.     puts("done.");
  63.     exit(1);
  64. }
  65.  
  66. Callot (n)            /* allot n words in the dictionary */
  67. short n;
  68. {
  69.     unsigned newsize;
  70.  
  71.     mem[DP] += n;            /* move DP */
  72.     if (mem[DP] + GULPFRQ > mem[LIMIT]) {    /* need space */
  73.     newsize = mem[DP] + GULPSIZE;
  74.     if (newsize > MAXMEM && MAXMEM)
  75.         errexit("ATTEMPT TO GROW PAST MAXMEM (%d) WORDS\n",MAXMEM);
  76. #ifdef AMIGA
  77.         /*
  78.          * Fake realloc by doing a malloc and copy to the new area.
  79.          * Since we are always just growing the area, this should work.
  80.          * Note that this has the disadvantage of requiring at least 2N
  81.      * bytes to grow an area of N bytes.
  82.          */
  83.         {
  84.             register char *new, *out;
  85.             register char *in = mem;
  86.             register int count = mem[LIMIT];
  87.             new = out = (short *) malloc ((char *)mem, newsize*sizeof(*mem));
  88.         if (new == NULL)
  89.             errexit("REALLOC FAILED\n");
  90.             while (count-- > 0) {
  91.             *out++ = *in++;
  92.         }
  93.             free (mem);
  94.             mem = new;
  95.         }
  96. #else
  97.     mem = (short *)realloc((char *)mem, newsize*sizeof(*mem));
  98.     if (mem == NULL)
  99.         errexit("REALLOC FAILED\n");
  100. #endif    /* AMIGA */
  101.     mem[LIMIT] = newsize;
  102.     }
  103. }
  104.  
  105. push(v)            /* push value v to cstack */
  106. short v;
  107. {
  108.     if (csp <= TIB_END)
  109.     errexit("PUSH TO FULL CALC. STACK\n");
  110.     mem[--csp] = v;
  111. }
  112.  
  113. short pop()            /* pop a value from comp. stack, and return
  114.                    it as the value of the function */
  115. {
  116.     if (csp >= INITS0) {
  117.     puts("Empty Stack!");
  118.     return 0;
  119.     }
  120.     return (mem[csp++]);
  121. }
  122.  
  123. rpush(v)
  124. short v;
  125. {
  126.     if (rsp <= INITS0)
  127.     errexit("PUSH TO FULL RETURN STACK");
  128.     mem[--rsp] = v;
  129. }
  130.  
  131. short rpop()
  132. {
  133.     if (rsp >= INITR0)
  134.     errexit("POP FROM EMPTY RETURN STACK!");
  135.     return (mem[rsp++]);
  136. }
  137.  
  138. pkey()            /* (KEY) -- wait for a key & return it */
  139. {
  140.     int c;
  141.     if ((c = getchar()) == EOF) errexit("END-OF-FILE ENCOUNTERED");
  142.     return(c);
  143. }
  144.  
  145. pqterm()            /* (?TERMINAL): 
  146.                     return true if BREAK has been hit */
  147. {
  148.     if (qtermflag) {
  149.         push(TRUE);
  150.         qtermflag = FALSE;    /* this influences ^C handling */
  151.     }
  152.     else push(FALSE);
  153. }
  154.  
  155. pemit()                /* (EMIT): c --    emit a character */
  156. {
  157.     putchar(pop() & 0x7f);    /* stdout is unbuffered */
  158. }
  159.  
  160. next()            /* instruction processor: control goes here
  161.                    almost right away, and cycles through here
  162.                    until you leave. */
  163.  
  164. /* 
  165.  * This is the big kabloona. What it does is load the value at mem[ip]
  166.  * into w, increment ip, and invoke prim. number w. This implies that
  167.  * mem[ip] is the CFA of a word. What's in the CF of a word is the number
  168.  * of the primitive which should be executed. For a word written in FORTH,
  169.  * that primitive is "docol", which pushes ip to the return stack, then
  170.  * uses w+2 (the PFA of the word) as the new ip.  See "interp.doc" for
  171.  * more.
  172.  */
  173.  
  174. /*
  175.  * There is an incredible hack going on here: the SPECIAL CASE mentioned in
  176.  * the code is for the word EXECUTE, which must set W itself and jump INSIDE
  177.  * the "next" loop, by-passing the first instruction. This has been made a
  178.  * special case: if the primitive to execute is zero, the special case is
  179.  * invoked, and the code for EXECUTE is put right in the NEXT loop. For this
  180.  * reason, "EXECUTE" MUST BE THE FIRST WORD IN THE DICTIONARY.
  181.  */
  182. {
  183.     short p;
  184.     
  185.     while (1) {
  186.     if (forceip) {        /* force ip to this value -- used by sig_int */
  187.         ip = forceip;
  188.         forceip = FALSE;
  189.     }
  190. #ifdef TRACE
  191.     if (trace) dotrace();
  192. #endif TRACE
  193.  
  194. #ifdef BREAKPOINT
  195.     if (breakenable && ip == breakpoint) dobreak();
  196. #endif BREAKPOINT
  197.  
  198.     w = mem[ip];
  199.     ip++;
  200.                 /* w, mem, and ip are all global. W is now
  201.                    a POINTER TO the primitive number to 
  202.                    execute, and ip points to the NEXT thread to
  203.                    follow. */
  204.  
  205. next1:                /* This is for the SPECIAL CASE */
  206.     p = mem[w];        /* p is the actual number of the primitive */
  207.     if (p == 0) {        /* SPECIAL CASE FOR EXECUTE! */
  208.         w = pop();        /* see above for explanation */
  209.         goto next1;
  210.     }
  211.     /* else */
  212.     switch(p) {
  213.     case LIT    :  lit(); break;
  214.     case BRANCH    :  branch(); break;
  215.     case ZBRANCH    :  zbranch(); break;
  216.     case PLOOP    :  ploop(); break;
  217.     case PPLOOP    :  pploop(); break;
  218.     case PDO    :  pdo(); break;
  219.     case I        :  i(); break;
  220.     case R        :  r(); break;
  221.     case DIGIT    :  digit(); break;
  222.     case PFIND    :  pfind(); break;
  223.     case ENCLOSE    :  enclose(); break;
  224.     case KEY    :  key(); break;
  225.     case PEMIT    :  pemit(); break;
  226.     case QTERMINAL    :  qterminal(); break;
  227.     case CMOVE    :  cmove(); break;
  228.     case USTAR    :  ustar(); break;
  229.     case USLASH    :  uslash(); break;
  230.     case AND    :  and(); break;
  231.     case OR        :  or(); break;
  232.     case XOR    :  xor(); break;
  233.     case SPFETCH    :  spfetch(); break;
  234.     case SPSTORE    :  spstore(); break;
  235.     case RPFETCH    :  rpfetch(); break;
  236.     case RPSTORE    :  rpstore(); break;
  237.     case SEMIS    :  semis(); break;
  238.     case LEAVE    :  leave(); break;
  239.     case TOR    :  tor(); break;
  240.     case FROMR    :  fromr(); break;
  241.     case ZEQ    :  zeq(); break;
  242.     case ZLESS    :  zless(); break;
  243.     case PLUS    :  plus(); break;
  244.     case DPLUS    :  dplus(); break;
  245.     case MINUS    :  minus(); break;
  246.     case DMINUS    :  dminus(); break;
  247.     case OVER    :  over(); break;
  248.     case DROP    :  drop(); break;
  249.     case SWAP    :  swap(); break;
  250.     case DUP    :  dup(); break;
  251.     case TDUP    :  tdup(); break;
  252.     case PSTORE    :  pstore(); break;
  253.     case TOGGLE    :  toggle(); break;
  254.     case FETCH    :  fetch(); break;
  255.     case CFETCH    :  cfetch(); break;
  256.     case TFETCH    :  tfetch(); break;
  257.     case STORE    :  store(); break;
  258.     case CSTORE    :  cstore(); break;
  259.     case TSTORE    :  tstore(); break;
  260.     case DOCOL    :  docol(); break;
  261.     case DOCON    :  docon(); break;
  262.     case DOVAR    :  dovar(); break;
  263.     case DOUSE    :  douse(); break;
  264.     case SUBTRACT    :  subtract(); break;
  265.     case EQUAL    :  equal(); break;
  266.     case NOTEQ    :  noteq(); break;
  267.     case LESS    :  less(); break;
  268.     case ROT    :  rot(); break;
  269.     case DODOES    :  dodoes(); break;
  270.     case DOVOC    :  dovoc(); break;
  271.     case ALLOT    :  allot(); break;
  272.     case PBYE    :  pbye(); break;
  273.     case TRON    :  tron(); break;
  274.     case TROFF    :  troff(); break;
  275.     case DOTRACE    :  dotrace(); break;
  276.     case PRSLW    :  prslw(); break;
  277.     case PSAVE    :  psave(); break;
  278.     case PCOLD    :  pcold(); break;
  279.     default        :  errexit("Bad execute-code %d\n",p); break;
  280.     }
  281.     }
  282. }
  283.  
  284. dotrace()
  285. {
  286.     short worka, workb, workc;
  287.     putchar('\n');
  288.     if (tracedepth) {        /* show any stack? */
  289.         printf("sp: %04x (", csp);
  290.         worka = csp;
  291.         for (workb = tracedepth; workb; workb--)
  292.             printf("%04x ",(unsigned short) mem[worka++]);
  293.         putchar(')');
  294.     }
  295.     printf(" ip=%04x ",ip);
  296.  
  297.     if (mem[R0]-rsp < RS_SIZE && mem[R0] - rsp > 0) /* if legal rsp */
  298.         for (worka = mem[R0]-rsp; worka; worka--) { /* indent */
  299.         putchar('>');
  300.         putchar(' ');
  301.         }
  302.     worka = mem[ip] - 3;        /* this is second-to-last letter, or
  303.                        the count byte */
  304.     while (!(mem[worka] & 0x80)) worka--;    /* skip back to count byte */
  305.     workc = mem[worka] & 0x2f;        /* workc is count value */
  306.     worka++;
  307.     while (workc--) putchar(mem[worka++] & 0x7f);
  308.     fflush(stdout);
  309.     if (debug) {        /* wait for \n -- any other input will dump */
  310.         char buffer[10];
  311.         if (*gets(buffer) != '\0') {
  312.             printf("dumping core... ");
  313.             fflush(stdout);
  314.             memdump();
  315.             puts("done.");
  316.         }
  317.     }
  318. }
  319.  
  320. #ifdef BREAKPOINT
  321. dobreak()
  322. {
  323.     int temp;
  324.     puts("Breakpoint.");
  325.     printf("Stack pointer = %x:\n",csp);
  326.     for (temp = csp; temp < INITS0; temp++)
  327.         printf("\t%04x",mem[temp]);
  328.     putchar('\n');
  329. }
  330. #endif BREAKPOINT
  331.  
  332. main(argc,argv)
  333. int argc;
  334. char *argv[];
  335. {
  336.     FILE *fp;
  337.     unsigned short size;
  338.     int i = 1;
  339.  
  340.     cfilename = COREFILE;    /* "forth.core" */
  341.     bfilename = BLOCKFILE;    /* "forth.block" */
  342.     sfilename = SAVEFILE;    /* "forth.newcore" */
  343.     trace = debug = breakenable = nobuf = 0;
  344.  
  345.     while (i < argc) {
  346.         if (*argv[i] == '-') {
  347.             switch (*(argv[i]+1)) {
  348. #ifdef TRACE
  349.             case 'd':            /* -d[n] */
  350.                 debug = 1;    /* ...and fall through */
  351.             case 't':            /* -t[n] */
  352.                 trace = TRUE;
  353.                 if (argv[i][2])
  354.                     tracedepth = (argv[i][2] - '0');
  355.                 else tracedepth = 0;
  356.                 break;
  357. #else !TRACE
  358.             case 'd':
  359.             case 't':
  360.                 fprintf(stderr,
  361.         "Must compile with TRACE defined for -t or -d\n");
  362.                 break;
  363. #endif TRACE
  364.             case 'c': if (++i == argc) usage(argv[0]);
  365.                   cfilename = argv[i];        /* -c file */
  366.                   break;
  367.             case 's': if (++i == argc) usage(argv[0]);
  368.                   sfilename = argv[i];        /* -s file */
  369.                   break;
  370. #ifdef BREAKPOINT
  371.             case 'p': if (++i == argc) usage(argv[0]);
  372.                   breakenable = TRUE;    /* -p xxxx */
  373.                   breakpoint = xtoi(argv[i]);
  374.                   break;
  375. #else !BREAKPOINT
  376.             case 'p': fprintf(stderr,
  377.         "Must compile with BREAKPOINT defined for -p");
  378.                   break;
  379. #endif BREAKPOINT
  380.             case 'b': if (++i == argc) usage();
  381.                   bfilename = argv[i]; /* -b blockfile */
  382.                   break;
  383.             case 'n': nobuf = TRUE;
  384.                   break;
  385.             default: usage(argv[0]);
  386.                  exit(1);
  387.             }
  388.         }
  389.         else usage(argv[0]);        /* not a dash */
  390.         i++;
  391.     }
  392.  
  393.     if ((fp = fopen(cfilename,"r")) == NULL) {
  394.         fprintf(stderr,"Forth: Could not open %s\n", cfilename);
  395.         exit(1);
  396.     }
  397.     if (fread(&size, sizeof(size), 1, fp) != 1) {
  398.         fprintf(stderr,"Forth: %s is empty.\n",cfilename);
  399.         exit(1) ;
  400.     }
  401.  
  402.     if ((mem = (short *)calloc(size, sizeof(*mem))) == NULL) {
  403.         fprintf(stderr, "Forth: unable to malloc(%d,%d)\n",
  404.             size, sizeof(*mem));
  405.         exit(1);
  406.     }
  407.  
  408.     mem[LIMIT] = size;
  409.  
  410.     if (fread(mem+1, sizeof(*mem), size-1, fp) != size-1) {
  411.         fprintf(stderr, "Forth: not %d bytes on %s.\n",
  412.             size, cfilename);
  413.         exit(1);
  414.     }
  415.  
  416.     fclose(fp);
  417.  
  418.     initsignals();
  419.  
  420.     getblockfile();
  421.  
  422.     if (!nobuf) setbuf(stdout,NULL);
  423.  
  424.     if (ip = mem[SAVEDIP]) {    /* if savedip != 0, that is */
  425.         csp = mem[SAVEDSP];
  426.         rsp = mem[SAVEDRP];
  427.         puts("restarting a saved FORTH image");
  428.     }
  429.     else {
  430.         ip = mem[COLDIP];    /* this is the ip passed from nf.c */
  431.             /* ip now points to a word holding the CFA of COLD */
  432.         rsp = INITR0;        /* initialize return stack */
  433.         csp = INITS0;
  434.     }
  435.     next();
  436.     /* never returns */
  437. }
  438.  
  439. usage(s)
  440. char *s;
  441. {
  442.     fprintf(stderr, "usage:\n");
  443.     fprintf(stderr, "%s [-t[n]] [-d[n]] [-p xxxx] [-n]\n",s);
  444.     fputs(stderr, "\t[-c corename] [-b blockname] [-s savename]\n");
  445.     fputs(stderr, "Where:\n");
  446.     fputs(stderr,
  447. "-t[n]\t\tsets trace mode\n");
  448.     fputs(stderr,
  449. "-d[n]\t\tsets trace mode and debug mode (waits for newline)");
  450.     fputs(stderr,
  451. "\t\t[n] above sets stack depth to display. Single digit, 0-9. Default 0.\n");
  452.     fputs(stderr,
  453. "-p xxxx\t\tsets a breakpoint at xxxx (in hex), shows stack when reached\n");
  454.     fputs(stderr,
  455. "-n\t\tleaves stdout line-buffered\n");
  456.     fprintf(stderr,
  457. "-c corename\tuses corename as the core image (default %s without -c)\n",
  458.         COREFILE);
  459.     fprintf(stderr,
  460. "-b blockname\tuses blockname as the blockfile (default %s without -b)\n",
  461.         BLOCKFILE);
  462.     fprintf(stderr,
  463. "-s savename\tuses savename as the save-image file (default %s without -s)\n",
  464.         SAVEFILE);
  465. }
  466.  
  467. memdump()        /* dump core. */
  468. {
  469.     int i;    /* top of RAM */
  470.     int temp, tempb, firstzero, nonzero;
  471.     char chars[9], outline[80], tstr[6];
  472.     FILE *dumpfile;
  473.  
  474.     dumpfile = fopen(DUMPFILE,"w");
  475.  
  476.     fprintf(dumpfile,
  477.         "CSP = 0x%x  RSP = 0x%x  IP = 0x%x  W = 0x%x  DP = 0x%x\n",
  478.         csp, rsp, ip, w, mem[DP]);
  479.  
  480.     for (temp = 0; temp < mem[LIMIT]; temp += 8) {
  481.         nonzero = FALSE;
  482.         sprintf(outline, "%04x:", temp);
  483.         for (i=temp; i<temp+8; i++) {
  484.             sprintf(tstr," %04x", (unsigned short)mem[i]);
  485.             strcat(outline, tstr);
  486.             tempb = mem[i] & 0x7f;
  487.             if (tempb < 0x7f && tempb >= ' ')
  488.                 chars[i%8] = tempb;
  489.             else
  490.                 chars[i%8] = '.';
  491.             nonzero |= mem[i];
  492.         }
  493.         if (nonzero) {
  494.             fprintf(dumpfile,"%s %s\n",outline,chars);
  495.             firstzero = TRUE;
  496.         }
  497.         else if (firstzero) {
  498.             fprintf(dumpfile, "----- ZERO ----\n");
  499.             firstzero = FALSE;
  500.         }
  501.     }
  502.     fclose(dumpfile);
  503. }
  504.  
  505. /* here is where ctype.h is used */
  506.  
  507. xtoi(s)
  508. char *s;
  509. {                /*  convert hex ascii to integer */
  510.     int temp = 0;
  511.  
  512.     while (isxdigit (*s)) {    /* first non-hex char ends */
  513.     temp <<= 4;        /* mul by 16 */
  514.     if (isupper (*s))
  515.         temp += (*s - 'A') + 10;
  516.     else
  517.         if (islower (*s))
  518.         temp += (*s - 'a') + 10;
  519.         else
  520.         temp += (*s - '0');
  521.     s++;
  522.     }
  523.     return temp;
  524. }
  525.  
  526. /*
  527.  * Interrupt (^C) handling: If the user hits ^C once, the next pqterm call
  528.  * will return TRUE. If he hits ^C again before pqterm is called, there will
  529.  * be a forced jump to ABORT next time we hit next(). If it is a primitive
  530.  * that is caught in an infinite loop, this won't help any.
  531.  */
  532.  
  533. sig_int()
  534. {
  535.     if (qtermflag) {        /* second time? */
  536.         forceip = mem[ABORTIP];    /* checked each time through next */
  537.         qtermflag = FALSE;
  538.         trace = FALSE;        /* stop tracing; reset */
  539.     }
  540.     else qtermflag = TRUE;
  541. }
  542.  
  543. initsignals()
  544. {
  545. #ifdef AMIGA
  546.     /* just ignore it for now, maybe it will go away :-) */
  547. #else
  548.     signal(SIGINT,sig_int);
  549. #endif
  550. }
  551.  
  552. getblockfile()
  553. {
  554.     /* recall that opening with mode "a+" opens for reading and writing */
  555.     /* with the pointer positioned at the end; this is so ftell returns */
  556.     /* the size of the file.                        */
  557.  
  558.     if ((blockfile = fopen(bfilename, "a+")) == NULL)
  559.         errexit("Can't open blockfile \"%s\"\n", bfilename);
  560.     bfilesize = ftell(blockfile);
  561.  
  562.     printf("Block file has %d blocks.\n",(int) (bfilesize/1024) - 1);
  563. }
  564.  
  565.